home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Moscow ML 1.42 / src / compiler / Location.sml < prev    next >
Encoding:
Text File  |  1997-08-18  |  4.6 KB  |  174 lines  |  [TEXT/R*ch]
  1. (* Printing a location in the source program *)
  2.  
  3. open BasicIO Nonstdio Lexing Parsing Fnlib Config Mixture;
  4.  
  5. datatype Location =
  6.     Loc of int     (* Position of the first character *)
  7.          * int     (* Position of the next character following the last one *)
  8. ;
  9.  
  10. val input_name = ref ""              (* Input file name *)
  11. and input_stream = ref std_in        (* Current input channel *)
  12. and input_lexbuf =                   (* Current lexbuf *)
  13.                  ref(createLexer(fn s => fn n => 0))
  14. ;
  15.  
  16. val nilLocation = Loc(0,0);
  17.  
  18. fun getCurrentLocation () =
  19.   Loc(symbolStart(), symbolEnd())
  20. ;
  21.  
  22. fun mkLoc x = (getCurrentLocation(), x);
  23.  
  24. fun xLR (loc, _) = loc
  25. and xL (Loc(l,r), _) = l
  26. and xR (Loc(l,r), _) = r
  27. ;
  28.  
  29. fun xxLR (Loc(l,_), _) (Loc(_,r),_) = Loc(l,r);
  30. fun xxRL (Loc(_,r), _) (Loc(l,_),_) = Loc(r,l);
  31.  
  32. fun errLines char1 char2 charline1 line1 line2 =
  33. (
  34.   msgString ", line "; msgInt line1;
  35.   if line2 <> line1 then ( msgString "-"; msgInt line2 ) else ();
  36.   msgString ", characters ";
  37.   msgInt (char1-charline1); msgString "-"; msgInt (char2-charline1);
  38.   msgString ":"
  39. );
  40.  
  41. fun msgChars n c =
  42.   if n > 0 then (msgChar c; msgChars (n-1) c) else ()
  43. ;
  44.  
  45. fun errLoc input seek line_flag (Loc(pos1, pos2)) =
  46.   let
  47.     fun skipLine () =
  48.       (case input() of #"\^Z" => () | #"\n" => () | _ => skipLine())
  49.       handle Size => ()
  50.     and copyLine () =
  51.       (case input() of
  52.            #"\^Z" => raise Size
  53.          | #"\n" => msgEOL()
  54.          | c => (msgChar c; copyLine()))
  55.       handle Size => (msgString "<EOF>"; msgEOL())
  56.     and tr_line first len ch =
  57.       let
  58.         val c = ref #" "
  59.         val f = ref first
  60.         val l = ref len
  61.         fun loop f l =
  62.           (case input() of
  63.                 #"\^Z" => raise Size
  64.               | #"\n" => ()
  65.               | c =>
  66.                   if f > 0 then
  67.                     (msgChar(if c = #"\t" then c else #" "); loop (f-1) l)
  68.                   else if l > 0 then
  69.                     (msgChar(if c = #"\t" then c else ch); loop f (l-1))
  70.                   else loop f l)
  71.           handle Size => msgChars 5 ch
  72.       in loop first len end
  73.     val pos = ref 0
  74.     val line1 = ref 1
  75.     val line1_pos = ref 0
  76.     val line2 = ref 1
  77.     val line2_pos = ref 0
  78.   in
  79.     seek 0;
  80.     (while !pos < pos1 do
  81.        (incr pos;
  82.         case input() of
  83.             #"\^Z" => raise Size
  84.           | #"\n" => (incr line1; line1_pos := !pos)
  85.           | _ => ()))
  86.     handle Size => ();
  87.     line2 := !line1;
  88.     line2_pos := !line1_pos;
  89.     (while !pos < pos2 do
  90.        (incr pos;
  91.         case input() of
  92.             #"\^Z" => raise Size
  93.           | #"\n" => (incr line2; line2_pos := !pos)
  94.           | _ => ()))
  95.     handle Size => ();
  96.     if line_flag then
  97.       errLines pos1 pos2 (!line1_pos) (!line1) (!line2)
  98.     else ();
  99.     msgEOL();
  100.     if !line1 = !line2 then
  101.       (seek (!line1_pos);
  102.        errPrompt ""; copyLine ();
  103.        seek (!line1_pos);
  104.        errPrompt ""; tr_line (pos1 - !line1_pos) (pos2 - pos1) #"^";
  105.        msgEOL())
  106.     else
  107.       (
  108.       seek (!line1_pos);
  109.       errPrompt ""; tr_line 0 (pos1 - !line1_pos) #".";
  110.       seek pos1;
  111.       copyLine();
  112.       if !line2 - !line1 <= 8 then
  113.         (for (fn i => (errPrompt ""; copyLine()))
  114.              (!line1 + 1) (!line2 - 1))
  115.       else
  116.         (for (fn i => (errPrompt ""; copyLine()))
  117.              (!line1 + 1) (!line1 + 3);
  118.          errPrompt ".........."; msgEOL();
  119.          for (fn i => skipLine())
  120.              (!line1 + 4) (!line2 - 4);
  121.          for (fn i => (errPrompt ""; copyLine()))
  122.              (!line2 - 3) (!line2 - 1));
  123.       errPrompt "";
  124.       (for (fn i => msgChar(input()))
  125.            (!line2_pos) (pos2 - 1);
  126.        tr_line 0 100 #".")
  127.       handle Size => msgString "<EOF>";
  128.       msgEOL()
  129.       )
  130.   end;
  131.  
  132. fun errLocation loc =
  133.   if size (!input_name) > 0 then
  134.     let val p = pos_in (!input_stream) in
  135.       msgString "File \""; msgString (!input_name); msgString "\"";
  136.       errLoc (fn () => input_char (!input_stream)) (seek_in (!input_stream))
  137.              true loc;
  138.       seek_in (!input_stream) p
  139.     end
  140.   else
  141.     let
  142.       val curr_pos = ref 0
  143.       fun input () =
  144.         let val c =
  145.           if !curr_pos >= 2048 then
  146.             raise Size
  147.           else if !curr_pos >= 0 then
  148.             CharVector.sub(getLexBuffer(!input_lexbuf), !curr_pos)
  149.           else
  150.             #"."
  151.         in incr curr_pos; c end
  152.       and seek pos =
  153.         curr_pos := pos - getLexAbsPos(!input_lexbuf)
  154.     in
  155.       errPrompt "Toplevel input:";
  156.       errLoc input seek false loc
  157.     end
  158. ;
  159.  
  160. fun errInputName () =
  161. (
  162.   msgString "File \"";
  163.   msgString (!input_name); msgString "\", line 1:"; msgEOL()
  164. );
  165.  
  166. fun errorMsg loc msg =
  167. (
  168.   msgIBlock 0;
  169.   errLocation loc;
  170.   errPrompt msg; msgEOL();
  171.   msgEBlock();
  172.   raise Toplevel
  173. );
  174.